Option Explicit
Sub DeleteObsolete(strEmail)
On Error GoTo notFoundTrap
Dim myOlApp As Outlook.Application
Dim myNameSpace As NameSpace
Dim myFolder As Items
Dim myItem As MailItem
Dim strFilter As String

'Launch an instance of Outlook
'Reference its MAPI Namespace
'Reference MAPI's Inbox folder
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myFolder = _
     myNameSpace.GetDefaultFolder(olFolderInbox).Items

'Find obsolete messages and delete them
loopTop:
strFilter = "[From] = """ & strEmail & """"
Set myItem = myFolder.Find(strFilter)

     myItem.Delete
     GoTo loopTop

deleteSpamExit:
'Clean up before exiting
Set myOlApp = Nothing
Exit Sub

notFoundTrap:

   If Err.Number = 91 Or Err.Number = 13 Then
        GoTo deleteSpamExit
   Else
        MsgBox Err.Number & ": " & vbCrLf & _
             Err.Description, vbCritical, _
             "Application Power Programming with VBA"
   End If

'Clean up before exiting
Set myOlApp = Nothing

End Sub
